home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic 4 Database How-To / Visual Basic 4 Database - How-to (The Waite Group)(1995).iso / newgroup.fr_ / newgroup.fr
Text File  |  1995-07-06  |  4KB  |  139 lines
  1. VERSION 4.00
  2. Begin VB.Form Form1 
  3.    BackColor       =   &H00C0C0C0&
  4.    Caption         =   "Create Group"
  5.    ClientHeight    =   2100
  6.    ClientLeft      =   1080
  7.    ClientTop       =   1530
  8.    ClientWidth     =   4980
  9.    BeginProperty Font 
  10.       name            =   "MS Sans Serif"
  11.       charset         =   0
  12.       weight          =   700
  13.       size            =   8.25
  14.       underline       =   0   'False
  15.       italic          =   0   'False
  16.       strikethrough   =   0   'False
  17.    EndProperty
  18.    Height          =   2505
  19.    Left            =   1020
  20.    LinkTopic       =   "Form1"
  21.    ScaleHeight     =   2100
  22.    ScaleWidth      =   4980
  23.    Top             =   1185
  24.    Width           =   5100
  25.    Begin VB.TextBox txtGroupName 
  26.       Height          =   315
  27.       Left            =   2160
  28.       TabIndex        =   3
  29.       Top             =   360
  30.       Width           =   2115
  31.    End
  32.    Begin VB.CommandButton cmdClose 
  33.       Cancel          =   -1  'True
  34.       Caption         =   "Cl&ose"
  35.       Height          =   555
  36.       Left            =   2520
  37.       TabIndex        =   2
  38.       Top             =   1080
  39.       Width           =   1755
  40.    End
  41.    Begin VB.CommandButton cmdCreateGroup 
  42.       Caption         =   "&Create Group"
  43.       Default         =   -1  'True
  44.       Height          =   555
  45.       Left            =   480
  46.       TabIndex        =   1
  47.       Top             =   1080
  48.       Width           =   1755
  49.    End
  50.    Begin VB.Label Label1 
  51.       Alignment       =   1  'Right Justify
  52.       AutoSize        =   -1  'True
  53.       BackColor       =   &H00C0C0C0&
  54.       Caption         =   "&Group name:"
  55.       Height          =   195
  56.       Left            =   780
  57.       TabIndex        =   0
  58.       Top             =   420
  59.       Width           =   1095
  60.    End
  61. End
  62. Attribute VB_Name = "Form1"
  63. Attribute VB_Creatable = False
  64. Attribute VB_Exposed = False
  65. Option Explicit
  66.  
  67. #If Win32 Then
  68.     Private Declare Function GetWindowsDirectory Lib "kernel32" _
  69.         Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, _
  70.         ByVal nSize As Long) As Long
  71. #Else
  72.     Private Declare Function GetWindowsDirectory Lib "Kernel" _
  73.         (ByVal lpBuffer As String, _
  74.         ByVal nSize As Integer) As Integer
  75. #End If
  76.  
  77.  
  78. Private Sub Form_Load()
  79.     Dim myUser As String, myPass As String
  80.     Dim winDir As String * 128
  81.     Dim dirLen As Integer
  82.     
  83.     ' On Error GoTo LoadError
  84.     ' Get the Windows directory and set the INI path.
  85.     dirLen = GetWindowsDirectory(winDir, 128)
  86.     If dirLen = 0 Then Error 32767
  87.     DBEngine.IniPath = Left$(winDir, dirLen) & "\VBDBHT.INI"
  88.     
  89.     ' Set the user and passwords for initial login.
  90.     myUser = "Admin"
  91.     myPass = "theboss"
  92.     DBEngine.DefaultUser = myUser
  93.     DBEngine.DefaultPassword = myPass
  94.  
  95. Exit Sub
  96. LoadError:
  97.     MsgBox Err & " " & Error$
  98. End
  99.  
  100. End Sub
  101.  
  102. Private Sub cmdCreateGroup_Click()
  103.     Dim newGroup As GROUP
  104.     Dim thePID As String
  105.     
  106.     On Error GoTo ChangeError
  107.     
  108.     If txtGroupName = "" Then Error 32765
  109.     thePID = txtGroupName
  110.     If Len(thePID) > 20 Then
  111.         thePID = Left$(thePID, 20)
  112.     Else
  113.         Do While Len(thePID) < 4
  114.             thePID = thePID & "_"
  115.         Loop
  116.     End If
  117.     Set newGroup = DBEngine.Workspaces(0).CreateGroup(txtGroupName, thePID)
  118.     DBEngine.Workspaces(0).Groups.Append newGroup
  119.     MsgBox "Group " & txtGroupName & " created", vbInformation
  120.     txtGroupName = ""
  121. Exit Sub
  122. ChangeError:
  123.     Dim msg As String
  124.     Select Case Err.Number
  125.         Case 3390
  126.             msg = "There is already a group named " & txtGroupName
  127.         Case 32765
  128.             msg = "You have not entered a group name"
  129.         Case Else
  130.             msg = Err.Description
  131.     End Select
  132.     MsgBox msg, vbExclamation
  133. End Sub
  134.  
  135. Private Sub cmdClose_Click()
  136.     End
  137. End Sub
  138.  
  139.